unit uSBDUnit_TestNode_InternalSupport;

interface
uses uSBDUnit_Model, uSBD_BaseTypes, uSBDUnit_Types, Classes;

type
ITestNodeEx = interface( ITestNode)
  // Internal access to all test nodes.
    ['{67A5EF03-BAC8-4275-97D6-07060BCFA228}']
    procedure SetName( const Value: string);
    procedure SetFailCount   ( Value: integer);
    procedure SetExecuteCount( Value: integer);
    procedure SetLoadCount   ( Value: integer);
    procedure AddChild( const Newbie: ITestNode);
    function  AddNewChild( Kind: TNodeKind; const Name: string = ''): ITestNode;
    procedure SetStatus( Value: TTestStatus; Stamp: TDateTime);  overload;
    procedure SetStatus( Value: TTestStatus);                    overload;
    procedure Clear;
    procedure SkipDisabledDeep;
    procedure SetEnabledDeep( Value: boolean);
    procedure UpdateTernaryChecked( doNotifications: boolean);
    procedure SetTestResult_Overall( Value: TExecutionResult);
    procedure ShutDown;
  end;


ITestNodeNonLeafEx = interface( ITestNodeEx)
  // Internal access to all non-leaf test nodes.
    ['{718D3222-3635-46F9-AED9-862C8CC94C6C}']
  end;

ITestSuiteNodeEx   = interface( ITestNodeNonLeafEx)
  // Internal access to all non-leaf test nodes.
    ['{8D373773-511D-4F49-8A04-F2587C40AF30}']
    procedure SetSuiteClass( Cls: TClass);
    procedure PowerDownSuite;
    function  GetSuite: ITestSuite;
    function  SuiteObject: TObject;
    function  SuiteClass: TClass;
  end;

ITestGroupEx   = interface( ITestNodeNonLeafEx)
  // Internal access to all non-leaf test nodes.
    ['{AAD779F2-0B63-4731-9B7C-71AAA3773DE5}']
  end;

ITestNodeRootEx   = interface( ITestNodeNonLeafEx)
  // Internal access to all non-leaf test nodes.
    ['{03332AD9-609F-4EFC-8EC0-37849B627E77}']
  end;

TTestPointPhase = (phSetup, phMainExecute, phTeardown);

RTestPointCursorMemento = record  // The real cursor is in an external enumerator.
                                  //  The cursor position is copied to this
                                  //  mememto within the TestCaseNode instance.
    FRunIdx: integer;        // Index into TCaseRunArray
    FRunCount: integer;      // Length of FRuns
    FPhase: TTestPointPhase;
    procedure ResetCursor;
  end;

ITestCaseEx   = interface( ITestNodeEx)
  // Internal access to the leaf nodes, which are the test cases.
    ['{4B92A9BB-96B4-453F-B276-F6F91CA96963}']
    procedure SetMethodIndex  ( MethodIdx: integer);
    procedure SetCursorMemento( const Memento: RTestPointCursorMemento);
    function  GetRunCount: integer;
  end;

IUpwardPropagator = interface
  ['{E259E273-DB50-463B-96C3-C23C00AB4541}']
    procedure DownwardStatusChange( Value: TTestStatus; const Child: ITestNode; Stamp: TDateTime);
    procedure DownwardFailCountChange( Delta: integer; const Child: ITestNode);
    procedure DownwardExecCountChange( Delta: integer; const Child: ITestNode);
    procedure DownwardLoadCountChange( Delta: integer; const Child: ITestNode);
    procedure DownwardExecutionResultChange( ChildResult: TExecutionResult; const Child: ITestNode);
  end;

INodeMaster = interface
  ['{D213B6B6-AA28-4FE9-AB12-975168C22C6E}']
    procedure NodePropertiesChanged( const Node: ITestNode; ChangeSet: TChangeableNodePropertySet);
    procedure NonFailMessageArrived( const Node: ITestNode; Idx: integer);
    procedure AddedNode( const Addend: ITestNode);
    procedure Failure( const Node: ITestCaseNode; const ErrMessage: string; WhenFailed: TDateTime);
  end;

INonFailMessageEx = interface( INonFailMessage)
  ['{FF3392FA-7671-4358-BE09-C8ED3B55C492}']
    procedure SetNonFailMessage( Stamp1: TDateTime; const Msg1: string);
  end;

ITestHarnessEx = interface( ITestHarness)
  ['{B4A093F1-8EE2-4C38-A7C4-EA404A607C92}']
    procedure Fail( const FailMessage: string );  // raise exception.
    procedure MarkFail( const FailMessage: string; WhenFail: TDateTime = 0.0);
    function  HasFailed: boolean;
    function  FailMessage: string;
    function  FailStamp: TDateTime;
    function  NonFailMessages: TNonFailMessageArray;
    procedure AddNonFailMessage( const Addend: INonFailMessage);
    procedure SetTestSuiteClass( Class1: TClass);
    procedure Clear;
    procedure ShutDown;
  end;

ITestHarnessExWithTestModulation = interface( ITestHarnessEx)
  ['{A5983B44-C21B-40EC-BF46-162A28F631D3}']
    procedure BeginLeakageSensing( doMonitor1: boolean);
    function  EndLeakageSensing: boolean;
  end;

ILeakageDetector = interface
  ['{9509E664-7FD6-4B89-B08E-9F0961FD3AE2}']
    procedure EnterMonitoring;
    function  LeaveMonitoring( var Leakage: int64): boolean;
    function  IsMonitoring: boolean;
    function  MonitoringSuppression: IInterface;
  end;

BooleanSet = set of boolean;
ITestEnumerableGetterEx = interface
  ['{1C770619-EBA1-44AF-A740-61D80E225493}']
    procedure SetEnumerateOverEnabled( ValidEnableStates: BooleanSet);
    procedure SetRoot( const RootNode: ITestNode);
  end;


RTestPointCursor = record
    FCurrentNode: ITestNode;
    FWithinNode: RTestPointCursorMemento;
  end;


UserFailException = class( TSBDUnit_Exception) end;


TTestSuiteHelper = class helper for TObject
  private
    procedure SetHarness( const Harness1: ITestHarness);
  public
    class function SuiteName: string;
    class function isValidTestSuiteClass: boolean;
    property Harness: ITestHarness  write SetHarness;
  end;

implementation





uses uSBDUnit_TestSuiteNodeImpl, SysUtils, Rtti;

{ RTestPointCursorMemento }

procedure RTestPointCursorMemento.ResetCursor;
begin
FRunIdx := 0;
FPhase  := phSetup;
end;


{ TTestSuiteHelper }

class function TTestSuiteHelper.isValidTestSuiteClass: boolean;
var
  Dom: TTestSuiteDomicile;
begin
result := Dom.CanCreate( self);
if not result then exit;
Dom.Create( self);
result := Dom.isValid;
Dom.Free
end;



type TTestSuiteProtAccess = class( TTestSuite)
  end;

procedure TTestSuiteHelper.SetHarness( const Harness1: ITestHarness);
var
  SuiteIntf: ITestSuite;
begin
  if self is TTestSuite then
      TTestSuiteProtAccess( self).FHarness := Harness1
    else if Supports( self, ITestSuite, SuiteIntf) then
      SuiteIntf.SetHarness( Harness1)
end;

class function TTestSuiteHelper.SuiteName: string;
var
  Context: TRttiContext;
  A: TCustomAttribute;
begin
result  := ClassName;
Context := TRttiContext.Create;
for A in Context.GetType( self).GetAttributes do
  begin
  if not A.InheritsFrom( TestSuite) then continue;
  result := TestSuite(A).Name;
  break
  end;
Context.Free;
end;


end.
